Celestin Apprentice 5/Apprentice-Release5.iso/Environments/PowerMacOberon feb96/Source/CRA.Mod

Oberon Text | 1994-07-11 | 25.8 KB | 814 lines | [.Ob./.Ob4]

Syntax10.Scn.Fnt
MODULE CRA;  (* handles the DFA *)
IMPORT Oberon, Texts, Sets, CRS, CRT;
CONST
    maxStates = 300;
    EOL = 0DX;
    State = POINTER TO StateNode;
    Action = POINTER TO ActionNode;
    Target = POINTER TO TargetNode;
    StateNode = RECORD         (*state of finite automaton*)
        nr: INTEGER;  (*state number*)
        firstAction: Action;   (*to first action of this state*)
        endOf: INTEGER;  (*nr. of recognized token if state is final*)
        ctx: BOOLEAN;  (*TRUE: state reached by contextTrans*)
        next: State
    END;
    ActionNode = RECORD    (*action of finite automaton*)
        typ: INTEGER;       (*type of action symbol: char, class*)
        sym: INTEGER;       (*action symbol*)
        tc: INTEGER;       (*transition code: normTrans, contextTrans*)
        target: Target;        (*states after transition with input symbol*)
        next: Action;
    END;
    TargetNode = RECORD    (*state after transition with input symbol*)
        state:  State;       (*target state*)
        next:   Target;
    END;
    Comment    = POINTER TO CommentNode;
    CommentNode = RECORD   (* info about a comment syntax *)
        start,stop: ARRAY 2 OF CHAR;
        nested:     BOOLEAN;
        next:       Comment;
    END;
    Melted     = POINTER TO MeltedNode;
    MeltedNode = RECORD    (* info about melted states *)
        set:   CRT.Set;      (* set of old states *)
        state: State;      (* new state *)
        next:  Melted;
    END;
    firstState: State;
    lastState:    State;      (* last allocated state  *)
    rootState:    State;      (* start state of DFA    *)
    lastSimState: INTEGER;      (* last non melted state *)
    stateNr: INTEGER;  (*number of last allocated state*)
    firstMelted:  Melted;       (* list of melted states *)
    firstComment: Comment;      (* list of comments      *)
    out: Texts.Writer;  (* current output *)
    fram: Texts.Reader;  (* scanner frame input *)
PROCEDURE SemErr(nr: INTEGER);
BEGIN CRS.Error(200+nr, CRS.pos)
END SemErr;
PROCEDURE Put(ch: CHAR);
BEGIN Texts.Write(out, ch) END Put;
PROCEDURE PutS(s: ARRAY OF CHAR);
    VAR i: INTEGER;
BEGIN i := 0;
    WHILE (i < LEN(s)) & (s[i] # 0X) DO
        IF s[i] = "$" THEN Texts.WriteLn(out) ELSE Texts.Write(out, s[i]) END;
        INC(i)
END PutS;
PROCEDURE PutI(i: INTEGER);
BEGIN Texts.WriteInt(out, i, 0) END PutI;
PROCEDURE PutI2(i, n: INTEGER);
BEGIN Texts.WriteInt(out, i, n) END PutI2;
PROCEDURE PutC(ch: CHAR);
BEGIN
    IF (ch < " ") OR (ORD(ch) = 34) THEN PutS("CHR("); PutI(ORD(ch)); Put(")")
    ELSE Put(CHR(34)); Put(ch); Put(CHR(34))
END PutC;
PROCEDURE PutRange(s: CRT.Set);
    VAR lo, hi: ARRAY 32 OF CHAR; top, i: INTEGER; s1: CRT.Set;
BEGIN
    (*----- fill lo and hi *)
    top := -1; i := 0;
    WHILE i < 128 DO
        IF Sets.In(s, i) THEN
            INC(top); lo[top] := CHR(i); INC(i);
            WHILE (i < 128) & Sets.In(s, i) DO INC(i) END;
            hi[top] := CHR(i - 1)
        ELSE INC(i)
        END
    END;
    (*----- print ranges *)
    IF (top = 1) & (lo[0] = 0X) & (hi[1] = 7FX) & (CHR(ORD(hi[0]) + 2) = lo[1]) THEN
        Sets.Fill(s1); Sets.Differ(s1, s); PutS("~ ("); PutRange(s1); Put(")")
    ELSE
        i := 0;
        WHILE i <= top DO
            IF hi[i] = lo[i] THEN   PutS("(ch="); PutC(lo[i])
            ELSIF lo[i] = 0X THEN   PutS("(ch<="); PutC(hi[i])
            ELSIF hi[i] = 7FX THEN PutS("(ch>="); PutC(lo[i])
            ELSE PutS("(ch>="); PutC(lo[i]); PutS(") & (ch<="); PutC(hi[i])
            END;
            Put(")");
            IF i < top THEN PutS(" OR ") END;
            INC(i)
        END
END PutRange;
PROCEDURE PutChCond(ch: CHAR);
BEGIN
    PutS("(ch ="); PutC(ch); Put(")")
END PutChCond;
PROCEDURE Length*(s: ARRAY OF CHAR): INTEGER;
    VAR i: INTEGER;
BEGIN
    i:=0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
    RETURN i
END Length;
PROCEDURE AddAction(act:Action; VAR head:Action);
VAR a,lasta: Action;
BEGIN
    a := head; lasta := NIL;
    LOOP
        IF (a = NIL)                (*collecting classes at the front gives better*)
        OR (act^.typ < a^.typ) THEN (*performance*)
            act^.next := a;
            IF lasta = NIL THEN head := act ELSE lasta^.next := act END;
            EXIT;
        END;
        lasta := a; a := a^.next;
    END;
END AddAction;
PROCEDURE DetachAction(a:Action; VAR L:Action);
BEGIN
    IF L = a THEN L := a^.next ELSIF L # NIL THEN DetachAction(a, L^.next) END
END DetachAction;
PROCEDURE TheAction (state: State; ch: CHAR): Action;
    VAR a: Action; set: CRT.Set;
BEGIN
    a := state.firstAction;
    WHILE a # NIL DO
        IF a.typ = CRT.char THEN
            IF ORD(ch) = a.sym THEN RETURN a END
        ELSIF a.typ = CRT.class THEN
            CRT.GetClass(a^.sym, set);
            IF Sets.In(set, ORD(ch)) THEN RETURN a END
        END;
        a := a.next
    END;
    RETURN NIL
END TheAction;
PROCEDURE AddTargetList(VAR lista, listb: Target);
VAR p,t: Target;
    PROCEDURE AddTarget(t: Target; VAR list:Target);
    VAR p,lastp: Target;
    BEGIN
        p:=list; lastp:=NIL;
        LOOP
            IF (p = NIL) OR (t^.state.nr < p^.state.nr) THEN EXIT END;
            IF p^.state = t^.state THEN RETURN END;
            lastp := p; p := p^.next
        END;
        t^.next:=p;
        IF lastp=NIL THEN list:=t ELSE lastp^.next:=t END
    END AddTarget;
BEGIN
    p := lista;
    WHILE p # NIL DO
        NEW(t); t^.state:=p^.state; AddTarget(t, listb);
        p := p^.next
END AddTargetList;
PROCEDURE NewMelted(set: CRT.Set; state: State): Melted;
VAR melt: Melted;
BEGIN
    NEW(melt); melt^.set := set; melt^.state := state;
    melt^.next := firstMelted; firstMelted := melt;
    RETURN melt
END NewMelted;
PROCEDURE NewState(): State;
    VAR state: State;
BEGIN
    NEW(state); INC(stateNr); state.nr := stateNr;
    state.firstAction := NIL; state.endOf := CRT.noSym; state.ctx := FALSE; state.next := NIL;
    IF firstState = NIL THEN firstState := state ELSE lastState.next := state END;
    lastState := state;
    RETURN state
END NewState;
PROCEDURE NewTransition(from, to: State; typ, sym, tc: INTEGER);
    VAR a: Action; t: Target;
BEGIN
    IF to = firstState THEN SemErr(21) END;
    NEW(t); t^.state := to; t^.next := NIL;
    NEW(a); a^.typ := typ; a^.sym := sym; a^.tc := tc; a^.target := t;
    AddAction(a, from.firstAction)
END NewTransition;
PROCEDURE NewComment*(from, to: INTEGER; nested: BOOLEAN);
    VAR com: Comment;
    PROCEDURE MakeStr(gp: INTEGER; VAR s: ARRAY OF CHAR);
        VAR i, n: INTEGER; gn: CRT.GraphNode; set: CRT.Set;
    BEGIN
        i := 0;
        WHILE gp # 0 DO
            CRT.GetNode(gp, gn);
            IF gn.typ = CRT.char THEN
                IF i < 2 THEN s[i] := CHR(gn.p1) END; INC(i)
            ELSIF gn.typ = CRT.class THEN
                CRT.GetClass(gn.p1, set);
                IF Sets.Elements(set, n) # 1 THEN SemErr(26) END;
                IF i < 2 THEN s[i] := CHR(n) END; INC(i)
            ELSE SemErr(22)
            END;
            gp := gn.next
        END;
        IF i > 2 THEN SemErr(25) ELSIF i < 2 THEN s[i] := 0X END
    END MakeStr;
BEGIN
    NEW(com);
    MakeStr(from, com^.start); MakeStr(to, com^.stop);
    com^.nested := nested;
    com^.next := firstComment; firstComment := com
END NewComment;
PROCEDURE MakeSet(p: Action; VAR set: CRT.Set);
BEGIN
    IF p^.typ = CRT.class THEN CRT.GetClass(p^.sym, set)
    ELSE Sets.Clear(set); Sets.Incl(set, p^.sym)
END MakeSet;
PROCEDURE ChangeAction(a: Action; set: CRT.Set);
VAR nr: INTEGER;
BEGIN
    IF Sets.Elements(set, nr) = 1 THEN a^.typ := CRT.char; a^.sym := nr
    ELSE
        nr := CRT.ClassWithSet(set);
        IF nr < 0 THEN nr := CRT.NewClass("#0", set) END; (*class with dummy name*)
        a^.typ := CRT.class; a^.sym := nr
END ChangeAction;
PROCEDURE CombineShifts;
    VAR state: State; n: INTEGER; a, b, c: Action; seta, setb: CRT.Set;
BEGIN
    state := firstState;
    WHILE state # NIL DO
        a := state.firstAction;
        WHILE a # NIL DO
            b := a^.next;
            WHILE b # NIL DO
                IF (a^.target^.state = b^.target^.state) & (a^.tc = b^.tc) THEN
                    MakeSet(a, seta); MakeSet(b, setb); Sets.Unite(seta, setb);
                    ChangeAction(a, seta);
                    c := b; b := b^.next; DetachAction(c, a)
                ELSE b := b^.next
                END
            END;
            a := a^.next
        END;
        state := state.next
END CombineShifts;
PROCEDURE DeleteRedundantStates;
    action: Action;
    state, s1, s2: State;
    used: CRT.Set;
    newState: ARRAY maxStates OF State;
    PROCEDURE FindUsedStates(state: State);
    VAR action: Action;
    BEGIN
        IF Sets.In(used, state.nr) THEN RETURN END;
        Sets.Incl(used, state.nr);
        action := state.firstAction;
        WHILE action # NIL DO
            FindUsedStates(action^.target^.state);
            action:=action^.next
        END
    END FindUsedStates;
    PROCEDURE DelUnused;
        VAR state: State;
    BEGIN
        state := firstState.next; lastState := firstState; stateNr := 0; (*firstState has number 0*)
        WHILE state # NIL DO
            IF Sets.In(used, state.nr) THEN INC(stateNr); state.nr := stateNr; lastState := state
            ELSE lastState.next := state.next
            END;
            state := state.next
        END
    END DelUnused;
BEGIN
    Sets.Clear(used); FindUsedStates(firstState);
    (*---------- combine equal final states ------------*)
    s1 := firstState.next;  (*first state cannot be final*)
    WHILE s1 # NIL DO
        IF Sets.In(used, s1.nr) & (s1.endOf # CRT.noSym) &  (s1.firstAction = NIL) & ~ s1.ctx THEN
            s2 := s1.next;
            WHILE s2 # NIL DO
                IF Sets.In(used, s2.nr) & (s1.endOf = s2.endOf) & (s2.firstAction = NIL) & ~ s2.ctx THEN
                    Sets.Excl(used, s2.nr); newState[s2.nr] := s1
                END;
                s2 := s2.next
            END
        END;
        s1 := s1.next
    END;
    state := firstState;    (*> state := firstState.next*)
    WHILE state # NIL DO
        IF Sets.In(used, state.nr) THEN
            action := state.firstAction;
            WHILE action # NIL DO
                IF ~ Sets.In(used, action.target.state.nr) THEN
                    action^.target^.state := newState[action.target.state.nr]
                END;
                action := action^.next
            END
        END;
        state := state.next
    END;
    DelUnused
END DeleteRedundantStates;
PROCEDURE ConvertToStates*(gp0, sp: INTEGER);
(*note: gn.line is abused as a state number!*)
    VAR n: INTEGER; S: ARRAY maxStates OF State;
    PROCEDURE TheState(gp: INTEGER): State;
        VAR state: State; gn: CRT.GraphNode;
    BEGIN
        IF gp = 0 THEN state := NewState(); state.endOf := sp; RETURN state
        ELSE CRT.GetNode(gp, gn); RETURN S[gn.line]
        END
    END TheState;
    PROCEDURE Step(from: State; gp: INTEGER);
        VAR gn: CRT.GraphNode;
    BEGIN
        IF gp = 0 THEN RETURN END;
        CRT.GetNode(gp, gn);
        CASE gn.typ OF
            CRT.class, CRT.char: NewTransition(from, TheState(ABS(gn.next)), gn.typ, gn.p1, gn.p2)
        | CRT.alt: Step(from, gn.p1); Step(from, gn.p2)
        | CRT.opt, CRT.iter: Step(from, ABS(gn.next)); Step(from, gn.p1)
        END
    END Step;
    PROCEDURE FindTrans(gp: INTEGER; state: State);
        VAR gn: CRT.GraphNode; new: BOOLEAN;
    BEGIN
        IF gp = 0 THEN RETURN END;  (*end of graph*)
        CRT.GetNode(gp, gn);
        IF gn.line # 0 THEN RETURN END;  (*already visited*)
        new := state = NIL;
        IF new THEN state := NewState() END;
        INC(n); S[n] := state; gn.line := n; CRT.PutNode(gp, gn);
        IF CRT.DelGraph(gp) THEN state.endOf := sp END; (*state is end state*)
        CASE gn.typ OF
            CRT.class, CRT.char: FindTrans(ABS(gn.next), NIL);
        | CRT.opt:  FindTrans(ABS(gn.next), NIL); FindTrans(gn.p1, state)
        | CRT.iter: FindTrans(ABS(gn.next), state); FindTrans(gn.p1, state)
        | CRT.alt:  FindTrans(gn.p1, state); FindTrans(gn.p2, state)
        END;
        IF new OR (state = firstState) & (gp = gp0) THEN (*start of a group of equally numbered nodes*)
            Step(state, gp)
        END
    END FindTrans;
BEGIN
    IF CRT.DelGraph(gp0) THEN SemErr(20) END;
    n := 0; FindTrans(gp0, firstState)
END ConvertToStates;
PROCEDURE MatchDFA* (s: ARRAY OF CHAR; sp: INTEGER; VAR matchedSp: INTEGER);
    VAR state, to: State; a: Action; i, len: INTEGER;
BEGIN (*s with quotes*)
    state := firstState; i := 1; len := Length(s) - 1;
    LOOP (*try to match s against existing DFA*)
        IF i = len THEN EXIT END;
        a := TheAction(state, s[i]);
        IF a = NIL THEN EXIT END;
        state := a.target.state; INC(i)
    END;
    WHILE i < len DO (*make new DFA for s[i..len-1]*)
        to := NewState();
        NewTransition(state, to, CRT.char, ORD(s[i]), CRT.normTrans);
        state := to; INC(i)
    END;
    matchedSp := state.endOf;
    IF state.endOf = CRT.noSym THEN state.endOf := sp END
END MatchDFA;
PROCEDURE SplitActions(a, b: Action);
VAR c: Action; seta, setb, setc: CRT.Set;
    PROCEDURE CombineTransCodes(t1, t2: INTEGER; VAR result:INTEGER);
    BEGIN
        IF t1 = CRT.contextTrans THEN result := t1 ELSE result := t2 END
    END CombineTransCodes;
BEGIN
    MakeSet(a, seta); MakeSet(b, setb);
    IF Sets.Equal(seta, setb) THEN
        AddTargetList(b^.target, a^.target);
        CombineTransCodes(a^.tc, b^.tc, a^.tc);
        DetachAction(b, a)
    ELSIF Sets.Includes(seta, setb) THEN
        setc := seta; Sets.Differ(setc, setb);
        AddTargetList(a^.target, b^.target);
        CombineTransCodes(a^.tc, b^.tc, b^.tc);
        ChangeAction(a, setc)
    ELSIF Sets.Includes(setb, seta) THEN
        setc := setb; Sets.Differ(setc, seta);
        AddTargetList(b^.target, a^.target);
        CombineTransCodes(a^.tc, b^.tc, a^.tc);
        ChangeAction(b, setc)
    ELSE
        Sets.Intersect(seta, setb, setc);
        Sets.Differ(seta, setc);
        Sets.Differ(setb, setc);
        ChangeAction(a, seta);
        ChangeAction(b, setb);
        NEW(c); c^.target:=NIL;
        CombineTransCodes(a^.tc, b^.tc, c^.tc);
        AddTargetList(a^.target, c^.target);
        AddTargetList(b^.target, c^.target);
        ChangeAction(c, setc);
        AddAction(c, a)
END SplitActions;
PROCEDURE MakeUnique(state: State; VAR changed:BOOLEAN);
VAR a, b: Action;
    PROCEDURE Overlap(a, b: Action): BOOLEAN;
        VAR seta, setb: CRT.Set;
    BEGIN
        IF a^.typ = CRT.char THEN
            IF b^.typ = CRT.char THEN RETURN a^.sym = b^.sym
            ELSE CRT.GetClass(b^.sym, setb); RETURN Sets.In(setb, a^.sym)
            END
        ELSE
            CRT.GetClass(a^.sym, seta);
            IF b^.typ = CRT.char THEN RETURN Sets.In(seta, b^.sym)
            ELSE CRT.GetClass(b^.sym, setb); RETURN ~ Sets.Different(seta, setb)
            END
        END
    END Overlap;
BEGIN
    a := state.firstAction; changed := FALSE;
    WHILE a # NIL DO
        b := a^.next;
        WHILE b # NIL DO
            IF Overlap(a, b) THEN SplitActions(a, b); changed:=TRUE END;
            b := b^.next;
        END;
        a:=a^.next
END MakeUnique;
PROCEDURE MeltStates(state: State; VAR correct:BOOLEAN);
    action:  Action;
    ctx:     BOOLEAN;
    endOf:   INTEGER;
    melt:    Melted;
    set:     CRT.Set;
    s:      State;
    changed: BOOLEAN;
    PROCEDURE AddMeltedSet(nr: INTEGER; VAR set: CRT.Set);
    VAR m: Melted;
    BEGIN
        m := firstMelted;
        WHILE (m # NIL) & (m^.state.nr # nr) DO m := m^.next END;
        IF m = NIL THEN HALT(98) END;
        Sets.Unite(set, m^.set);
    END AddMeltedSet;
    PROCEDURE GetStateSet(t: Target; VAR set: CRT.Set; VAR endOf: INTEGER; VAR ctx:BOOLEAN);
    VAR statenr: INTEGER; (*lastS: State;*)
    BEGIN
        Sets.Clear(set); endOf := CRT.noSym; ctx := FALSE; (*lastS := NIL;*)
        WHILE t # NIL DO
            statenr := t.state.nr;
            IF statenr <= lastSimState THEN Sets.Incl(set, statenr)
            ELSE AddMeltedSet(statenr, set)
            END;
            IF t^.state^.endOf # CRT.noSym THEN
                IF (endOf = CRT.noSym) OR (endOf = t^.state^.endOf)
                (*OR (lastS^.firstAction # NIL) & (t^.state^.firstAction = NIL)*) THEN
                    endOf := t^.state.endOf; (*lastS := t^.state*)
                ELSE
                    PutS("$Tokens "); PutI(endOf); PutS(" and "); PutI(t^.state.endOf);
                    PutS(" cannot be distinguished.$");
                    correct:=FALSE
                END
            END;
            IF t^.state.ctx THEN ctx := TRUE;
                IF t.state.endOf # CRT.noSym THEN
                    PutS("$Ambiguous CONTEXT clause.$"); correct := FALSE
                END
            END;
            t := t^.next
        END
    END GetStateSet;
    PROCEDURE FillWithActions(state: State; targ: Target);
    VAR action,a: Action;
    BEGIN
        WHILE targ # NIL DO
            action := targ^.state.firstAction;
            WHILE action # NIL DO
                NEW(a); a^ := action^; a^.target := NIL;
                AddTargetList(action^.target, a^.target);
                AddAction(a, state.firstAction);
                action:=action^.next
            END;
            targ:=targ^.next
        END;
    END FillWithActions;
    PROCEDURE KnownMelted(set:CRT.Set; VAR melt: Melted): BOOLEAN;
    BEGIN
        melt := firstMelted;
        WHILE melt # NIL DO
            IF Sets.Equal(set, melt^.set) THEN RETURN TRUE END;
            melt := melt^.next
        END;
        RETURN FALSE
    END KnownMelted;
BEGIN
    action := state.firstAction;
    WHILE action # NIL DO
        IF action^.target^.next # NIL THEN (*more than one target state*)
            GetStateSet(action^.target, set, endOf, ctx);
            IF ~ KnownMelted(set, melt) THEN
                s := NewState(); s.endOf := endOf; s.ctx := ctx;
                FillWithActions(s, action^.target);
                REPEAT MakeUnique(s, changed) UNTIL ~ changed;
                melt := NewMelted(set, s);
            END;
            action^.target^.next:=NIL;
            action^.target^.state := melt^.state
        END;
        action := action^.next
    END;
    Texts.Append(Oberon.Log, out.buf)
END MeltStates;
PROCEDURE MakeDeterministic*(VAR correct: BOOLEAN);
    VAR state: State; changed: BOOLEAN;
    PROCEDURE FindCtxStates; (*find states reached by a context transition*)
    VAR a: Action; state: State;
    BEGIN
        state := firstState;
        WHILE state # NIL DO
            a := state.firstAction;
            WHILE a # NIL DO
                IF a^.tc = CRT.contextTrans THEN a^.target^.state.ctx := TRUE END;
                a := a^.next
            END;
            state := state.next
        END;
    END FindCtxStates;
BEGIN
    IF lastState = NIL THEN lastSimState := 0 ELSE lastSimState := lastState.nr END;
    FindCtxStates;
    state := firstState;
    WHILE state # NIL DO
        REPEAT MakeUnique(state, changed) UNTIL ~ changed;
        state := state.next
    END;
    correct := TRUE;
    state := firstState;
    WHILE state # NIL DO MeltStates(state, correct); state := state.next END;
    DeleteRedundantStates;
    CombineShifts
END MakeDeterministic;
PROCEDURE PrintSymbol(typ, val, width: INTEGER);
VAR name: CRT.Name; len: INTEGER;
BEGIN
    IF typ = CRT.class THEN
        CRT.GetClassName(val, name); PutS(name); len := Length(name)
    ELSIF (val >= ORD(" ")) & (val < 127) & (val # 34) THEN
        Put(CHR(34)); Put(CHR(val)); Put(CHR(34)); len:=3
    ELSE
        PutS("CHR("); PutI2(val, 2); Put(")"); len:=7
    END;
    WHILE len < width DO Put(" "); INC(len) END
END PrintSymbol;
PROCEDURE PrintStates*;
VAR action: Action; first: BOOLEAN; state: State; i: INTEGER; targ: Target; set: CRT.Set; name: CRT.Name;
BEGIN
    PutS("$-------- states ---------$");
    state := firstState;
    WHILE state # NIL DO
        action := state.firstAction; first:=TRUE;
        IF state.endOf = CRT.noSym THEN PutS("     ")
        ELSE PutS("E("); PutI2(state.endOf, 2); Put(")")
        END;
        PutI2(state.nr, 3); Put(":"); IF action = NIL THEN PutS(" $") END;
        WHILE action # NIL DO
            IF first THEN Put(" "); first:=FALSE ELSE PutS("          ") END;
            PrintSymbol(action^.typ, action^.sym, 0); Put(" ");
            targ := action^.target;
            WHILE targ # NIL DO
                PutI(targ^.state.nr); Put(" "); targ := targ^.next;
            END;
            IF action^.tc = CRT.contextTrans THEN PutS(" context$") ELSE PutS(" $") END;
            action := action^.next
        END;
        state := state.next
    END;
    PutS("$-------- character classes ---------$");
    i := 0;
    WHILE i <= CRT.maxC DO
        CRT.GetClass(i, set); CRT.GetClassName(i, name); PutS(name); PutS(": ");
        Sets.Print(out, set, 80, 13); Texts.WriteLn(out);
        INC(i)
    END;
    Texts.Append(Oberon.Log, out.buf)
END PrintStates;
PROCEDURE GenComment(com:Comment);
    PROCEDURE GenBody;
    BEGIN
        PutS("      LOOP$");
        PutS("        IF "); PutChCond(com^.stop[0]); PutS(" THEN$");
        IF Length(com^.stop) = 1 THEN
            PutS("          DEC(level); oldEols := chLine - startLine; NextCh;$");
            PutS("          IF level = 0 THEN RETURN TRUE END;$");
        ELSE
            PutS("          NextCh;$");
            PutS("          IF "); PutChCond(com^.stop[1]); PutS(" THEN$");
            PutS("            DEC(level); oldEols := chLine - startLine; NextCh;$");
            PutS("            IF level=0 THEN RETURN TRUE END$");
            PutS("          END;$");
        END;
        IF com^.nested THEN
            PutS("        ELSIF "); PutChCond(com^.start[0]); PutS(" THEN$");
            IF Length(com^.start) = 1 THEN
                PutS("          INC(level); NextCh;$");
            ELSE
                PutS("          NextCh;$");
                PutS("          IF "); PutChCond(com^.start[1]); PutS(" THEN$");
                PutS("            INC(level); NextCh;$");
                PutS("          END;$");
            END;
            END;
        PutS("        ELSIF ch = EOF THEN RETURN FALSE$");
        PutS("        ELSE NextCh END;$");
        PutS("      END;$");
        END GenBody;
BEGIN
    PutS("  IF "); PutChCond(com^.start[0]); PutS(" THEN$");
    IF Length(com^.start) = 1 THEN
        PutS("    NextCh;$");
        GenBody;
        PutS("  END;");
    ELSE
        PutS("    NextCh;$");
        PutS("    IF "); PutChCond(com^.start[1]); PutS(" THEN$");
        PutS("      NextCh;$");
        GenBody;
        PutS("    ELSE$");
        PutS("      IF ch = EOL THEN DEC(chLine); lineStart := oldLineStart END;$");
        PutS("      DEC(chPos, 2); Texts.OpenReader(r, src, chPos+1); NextCh; RETURN FALSE$");
        PutS("    END$");
        PutS("  END;");
    END;
    END GenComment;
PROCEDURE CopyFramePart (stopStr: ARRAY OF CHAR); (*Copy from file <fram> to file <out> until <stopStr>*)
    VAR ch, startCh: CHAR; i, j, high: INTEGER;
BEGIN
    startCh := stopStr[0]; high := Length(stopStr) - 1; Texts.Read (fram, ch);
    WHILE ch # 0X DO
        IF ch = startCh THEN (* check if stopString occurs *)
            i := 0;
            REPEAT
                IF i = high THEN RETURN END;  (*stopStr[0..i] found; no unrecognized character*)
                Texts.Read (fram, ch); INC(i);
            UNTIL ch # stopStr[i];
            (*stopStr[0..i-1] found; 1 unrecognized character*)
            j := 0; WHILE j < i DO Texts.Write(out, stopStr[j]); INC(j) END
        ELSE Texts.Write (out, ch); Texts.Read(fram, ch)
        END
END CopyFramePart;
PROCEDURE GenLiterals;
    VAR
        i, j, k, l: INTEGER;
        key: ARRAY 128 OF CRT.Name;
        knr: ARRAY 128 OF INTEGER;
        ch: CHAR;
        sn: CRT.SymbolNode;
BEGIN
    (*-- sort literal list*)
    i := 0; k := 0;
    WHILE i <= CRT.maxT DO
        CRT.GetSym(i, sn);
        IF sn.struct = CRT.litToken THEN
            j := k-1; WHILE (j >= 0) & (sn.name < key[j]) DO key[j+1] := key[j]; knr[j+1] := knr[j]; DEC(j) END;
            key[j+1] := sn.name; knr[j+1] := i; INC(k)
        END;
        INC(i)
    END;
    (*-- print case statement*)
    IF k > 0 THEN
        PutS("    IF (lexeme[0] >= "); PutC(key[0, 1]); PutS(") & (lexeme[0] <= "); PutC(key[k-1, 1]); PutS(") THEN$");
        PutS("      CASE lexeme[0] OF$");
        i := 0;
        WHILE i < k DO
            ch := key[i, 1];  (*key[i, 0] = quote*)
            PutS("      | "); PutC(ch); j := i;
            REPEAT
                IF i = j THEN PutS(": IF lexeme = ") ELSE PutS("        ELSIF lexeme = ") END;
                PutS(key[i]); PutS(" THEN sym := "); PutI(knr[i]); Put(CHR(13));
                INC(i)
            UNTIL (i = k) OR (key[i, 1] # ch);
            PutS("        END$");
        END;
        PutS("      ELSE$      END$    END;$")
END GenLiterals;
PROCEDURE WriteState(state: State);
    VAR action: Action; first, ctxEnd: BOOLEAN; sn: CRT.SymbolNode; endOf: INTEGER;
        set: CRT.Set;
BEGIN
    endOf := state.endOf;
    IF (endOf > CRT.maxT) & (endOf # CRT.noSym) THEN (*pragmas have been moved*)
        endOf := CRT.maxT + CRT.maxSymbols - endOf
    END;
    PutS("    | "); PutI2(state.nr, 2); PutS(": ");
    first:=TRUE; ctxEnd := state.ctx;
    action := state.firstAction;
    WHILE action # NIL DO
        IF first THEN PutS("IF "); first:=FALSE ELSE PutS("          ELSIF ") END;
        IF action^.typ = CRT.char THEN PutChCond(CHR(action^.sym))
        ELSE CRT.GetClass(action^.sym, set); PutRange(set)
        END;
        PutS(" THEN");
        IF action.target.state.nr # state.nr THEN
            PutS(" state := "); PutI(action.target.state.nr); Put(";")
        END;
        IF action^.tc = CRT.contextTrans THEN PutS(" INC(apx)"); ctxEnd := FALSE
        ELSIF state.ctx THEN PutS(" apx := 0")
        END;
        PutS(" $");
        action := action^.next
    END;
    IF state.firstAction # NIL THEN PutS("          ELSE ") END;
    IF endOf = CRT.noSym THEN PutS("sym := noSym; ")
    ELSE (*final state*)
        CRT.GetSym(endOf, sn);
        IF ctxEnd THEN (*final context state: cut appendix*)
            PutS("chPos := chPos - apx - 1; Texts.OpenReader(r, src, chPos+1); NextCh; ")
        END;
        PutS("sym := "); PutI(endOf); PutS("; ");
        IF sn.struct = CRT.classLitToken THEN PutS("CheckLiteral; ") END
    END;
    PutS("RETURN$");
    IF state.firstAction # NIL THEN PutS("          END;$") END
END WriteState;
PROCEDURE *Show (t: Texts.Text; op: INTEGER; beg, end: LONGINT);
END Show;
PROCEDURE WriteScanner*;
    scanner: ARRAY 32 OF CHAR;
    name:     ARRAY 64 OF CHAR;
    startTab: ARRAY 128 OF INTEGER;
    com:      Comment;
    i, j, l:  INTEGER;
    gn:       CRT.GraphNode;
    sn:       CRT.SymbolNode;
    state: State;
    t: Texts.Text;
    PROCEDURE FillStartTab;
        VAR action: Action; i, targetState: INTEGER; class: CRT.Set;
    BEGIN
        startTab[0] := stateNr + 1; (*eof*)
        i := 1; WHILE i < 128 DO startTab[i] := 0; INC(i) END;
        action := firstState.firstAction;
        WHILE action # NIL DO
            targetState := action.target.state.nr;
            IF action^.typ = CRT.char THEN
                startTab[action^.sym] := targetState
            ELSE
                CRT.GetClass(action^.sym, class); i := 0;
                WHILE i < 128 DO
                    IF Sets.In(class, i) THEN startTab[i] := targetState END;
                    INC(i)
                END
            END;
            action := action^.next
        END
    END FillStartTab;
BEGIN
    FillStartTab;
    CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
    COPY(sn.name, scanner); l := Length(scanner); scanner[l] := "S"; scanner[l+1] := 0X;
    NEW(t); Texts.Open(t, "Scanner.FRM"); Texts.OpenReader(fram, t, 0);
    IF t.len = 0 THEN
        Texts.WriteString(out, "Scanner.FRM not found"); Texts.WriteLn(out);
        Texts.Append(Oberon.Log, out.buf); HALT(99)
    END;
    Texts.Append(Oberon.Log, out.buf);
    (*------- *S.MOD -------*)
    CopyFramePart("-->modulename"); PutS(scanner);
    CopyFramePart("-->declarations"); PutS("  noSym = "); PutI(CRT.maxT); Put(";");
    CopyFramePart("-->comment");
    com := firstComment;
    WHILE com # NIL DO GenComment(com); com := com^.next END;
    CopyFramePart("-->literals"); GenLiterals;
    CopyFramePart("-->GetSy1");
    IF ~ Sets.In(CRT.ignored, ORD(EOL)) THEN PutS("  IF oldEols > 0 THEN DEC(oldEols); ch := EOL END;$") END;
    PutS("  WHILE (ch=20X)"); IF ~ Sets.Empty(CRT.ignored) THEN PutS(" OR ") END;
    PutRange(CRT.ignored); PutS(" DO NextCh END;");
    IF firstComment # NIL THEN
        PutS("$    IF ("); com := firstComment;
        WHILE com # NIL DO
            PutChCond(com^.start[0]);
            IF com^.next # NIL THEN PutS(" OR ") END;
            com := com^.next
        END;
        PutS(") & Comment() THEN Get(sym); RETURN END;")
    END;
    CopyFramePart("-->GetSy2");
    state := firstState.next;
    WHILE state # NIL DO WriteState(state); state := state.next END;
    PutS("    | "); PutI2(stateNr + 1, 2); PutS(": sym := 0; ch := 0X; RETURN$");
    CopyFramePart("-->initialization");
    i := 0;
    WHILE i < 32 DO
        j := 0; PutS("  ");
        WHILE j < 4 DO
            PutS("start["); PutI(4*i+j); PutS("]:="); PutI(startTab[4*i+j]); PutS("; ");
            INC(j)
        END;
        Texts.WriteLn(out);
        INC(i)
    END;
    CopyFramePart("-->modulename"); PutS(scanner); Put(".");
    NEW(t); t.notify := Show; Texts.Open(t, ""); Texts.Append(t, out.buf);
    l := Length(scanner); scanner[l] := "."; scanner[l+1] := "M"; scanner[l+2] := "o"; scanner[l+3] := "d"; scanner[l+4] := 0X;
    Texts.Close(t, scanner)
END WriteScanner;
PROCEDURE Init*;
BEGIN
    firstState := NIL; lastState := NIL; stateNr := -1;
    rootState := NewState();
    firstMelted := NIL; firstComment := NIL
END Init;
BEGIN
    Texts.OpenWriter(out)
END CRA.